home *** CD-ROM | disk | FTP | other *** search
/ Aminet 1 (Walnut Creek) / Aminet - June 1993 [Walnut Creek].iso / aminet / util / gnu / gnu_tile_forth.lha / tst / permutations.tst < prev    next >
Text File  |  1992-05-19  |  1KB  |  56 lines
  1. .( Loading Permutation benchmark...) cr
  2.  
  3. \ A heavily recursive permutation program written by Denny Brown
  4. \
  5. \ Part of the programs gathered by John Hennessy for the MIPS
  6. \ RISC project at Stanford. Translated to forth by Martin Freemen,
  7. \ Johns Hopkins University/Applied Physics Laboratory.
  8.  
  9. : exchange ( x y -- ) dup @ rot dup @ >r ! r> swap ! ;
  10.  
  11. : array ( size -- )
  12.   create 1+ cells allot immediate
  13. does> ( index array -- ptr)
  14.   [compile] literal
  15.   ?compile swap
  16.   ?compile cells
  17.   ?compile +
  18. ;
  19.  
  20. 10 constant permrange
  21. align permrange array permarray
  22. variable pctr
  23.  
  24. : initialize-array ( -- )
  25.   8 1 do i 1- i permarray ! loop
  26. ;
  27.  
  28. : permute ( n -- )
  29.   1 pctr +!
  30.   dup 1 = not
  31.   if dup 1- dup recurse
  32.     begin
  33.       dup 0>
  34.     while
  35.       over permarray over permarray exchange
  36.       over 1- recurse
  37.       over permarray over permarray exchange
  38.       1-
  39.     repeat
  40.     drop
  41.   then
  42.   drop
  43. ;
  44.  
  45. : permutations ( -- )
  46.   0 pctr !
  47.   6 1 do
  48.     initialize-array
  49.     7 permute
  50.   loop
  51.   pctr @ 43300 = not abort" permutations: wrong result"
  52. ;
  53.  
  54. forth only
  55.   
  56.